(in-package :parameterscout)

(defun read-infix-expression (string)
  "Given an infix expression as a string, return a lispified version of it."
  (let ((*read-eval* nil))
    (values (read-from-string (format nil "#I(~A)" (string-remove-metric-prefixes string))))))

(defun prompt-for-line ()
  "Print a prompt and return the entered line"
  (format *query-io* "~&> ")
  (finish-output *query-io*)
  (read-line *query-io* nil nil nil))

(defun read-number-from-string (string)
  (coerce (read-infix-expression string) 'double-float))

(defun pause ()
  (format *query-io* "Press Enter to continue...")
  (read-line *query-io* nil nil nil)
  nil)

(defun parse-integer-safe (string)
  "Like parse-integer, but returns an empty string if there's any problem."
  (or (handler-case (parse-integer string)
	(parse-error () nil))
      ""))

(defun prompt-for-free-variable-values (variable-name)
  (let ((defaults-p (suggested-values-exist-p variable-name))
	line)
    (tagbody
       (format *query-io* "~&Enter values for ~A, separated by commas. " variable-name)
       (when defaults-p
	 (format *query-io* "Press ENTER to use the default values."))
     :query-again
       (setf line (prompt-for-line))
       (return-from prompt-for-free-variable-values
	 (if (zerop (length line))
	     (if defaults-p
		 (query-for-which-defaults variable-name)
		 (progn
		   (format *query-io* "Please enter some values. For example: \"1, 2, 3\" would work.~%")
		   (go :query-again)))
	     (handler-case (coerce (mapcar #'read-number-from-string
					   (split-sequence #\, line :remove-empty-subseqs t))
				   'simple-vector)
	       (error (e)
		 (format *query-io* "Error: ~A" e)
		 (go :query-again))))))))

(defun query-for-which-defaults (variable-name)
  "Ask the user which set of default values to use for
  variable-name, assuming that such defaults exist. Return the
  default values."
  (multiple-value-bind (var-type max-elements) (suggested-values-exist-p variable-name)
    (if (= max-elements 1)
	(return-suggested-values variable-name 1)
	(prog (line number-of-elements)
	 :prompt
	 (format *query-io* "How many ~(~A~)s are you willing to use to get each value?" var-type)
	 (format *query-io* " (1-~A, default 1)~%" max-elements)
	 (setf line (prompt-for-line))
	 (if (zerop (length line))
	     (setf number-of-elements 1)
	     (setf number-of-elements (parse-integer-safe line)))
	 (unless (<= 1 number-of-elements max-elements)
	   (format *query-io* "The number of ~(~A~)s must be between 1 and ~A.~%" var-type max-elements)
	   (go :prompt))
	 (return (return-suggested-values variable-name number-of-elements))))))

(defun prompt-for-bindings (variable-names)
  "Given a list of variable names, prompt the user for values and
return a bindings list suitable for use with the solver macros."
  (loop for var in variable-names
     collect (list var (prompt-for-free-variable-values var))))

(defun simple-toplevel ()
  (let (expression free-variables bindings target answers)
    (tagbody
       (format *query-io* "Enter an expression. For example, if you wanted
to calculate the two resistors to put in parallel to get a
specified resistance, you might say \"r1*r2/(r1+r2)\".~%")
     :query-for-expression
       (handler-case (setf expression (read-infix-expression (prompt-for-line)))
	 (error (e)
	   (format *query-io* "Error: ~A" e)
	   (go :query-for-expression)))
       (setf free-variables (identify-free-variables expression))
       (format *query-io* "Enter the target value for the expression. Variable values
will be chosen to make the expression as close as possible
to the target value that you give.~%")
     :query-for-target
       (handler-case (setf target (coerce (eval (read-infix-expression (prompt-for-line))) 'double-float))
	 (error (e)
	   (format *query-io* "Error: ~A" e)
	   (go :query-for-target)))
     :query-for-free-variables
       (setf free-variables (identify-free-variables expression))
       (format *query-io* "Variables: ~{~a~^, ~}~%~%" free-variables)
       (setf bindings (prompt-for-bindings free-variables))
       ;; Find the answer
       (setf answers (perform-search expression bindings target))
       ;; Display the answer
       (format *query-io* "Answers found:~%")
       (dolist (answer answers)
	 (format *query-io* "~{~a~^, ~}~%"
		 (loop for var in (cons 'value free-variables)
		    for i from 0
		    collect (format nil "~A = ~A" var (print-float-for-engineers (svref answer i)))))))))

;; Best resistor fits
;;;;;;;;;;;;;;;;;;;;;

;; Two resistors:

(defun err< (soln1 soln2 &key target)
  "Return true if the error in solution SOLN1 is less than the
   error of SOLN2, false otherwise. Error is measured relative to
   mandatory keyword argument TARGET."
  (assert target)
  (< (abs (- (elt soln1 0) target))
     (abs (- (elt soln2 0) target))))

(defun find-best-series-2-resistor-fit (target)
  "Find the best combination of two resistors in series to get
  the combined target resistance given."
  (perform-search '(+ r1 r2) 
		  '((r1 *standard-resistor-values*)
		    (r2 *standard-resistor-values*))
		  target))

(defun find-best-parallel-2-resistor-fit (target)
  "Find the best combination of two resistors in parallel to get
  the combined target resistance given."
  (perform-search '(/ (* r1 r2) (+ r1 r2)) 
		  '((r1 *standard-resistor-values*)
		    (r2 *standard-resistor-values*))
		  target))

(defmacro find-best-fit ((target) &body function-keyword-pairs)
  (let* ((functions (mapcar #'car  function-keyword-pairs))
	 (keywords  (mapcar #'cadr function-keyword-pairs))
	 (soln-syms (mapcar (compose #'gensym #'symbol-name) keywords)))
    (once-only (target)
      (with-unique-names (soln sym)
	`(let ,(loop for function in functions
		  for soln-sym in soln-syms
		  collect `(,soln-sym (,function ,target)))
	   (destructuring-bind (,soln . ,sym)
	       (extremum (mapcar #'cons (list ,@soln-syms) ',keywords)
			 #'(lambda (a b) (err< a b :target ,target))
			 :key #'caar)
	     (values ,soln ,sym)))))))

(defun find-best-2-resistor-fit (target)
  "Find the best combination of two resistors to get the combined
  target resistance given. Return the fit vector
  and :series-2-resistor or :parallel-2-resistor."
  (find-best-fit (target)
    (find-best-series-2-resistor-fit   :series-2-resistor)
    (find-best-parallel-2-resistor-fit :parallel-2-resistor)))

;; Three resistors:

(defun find-best-1series-2parallel-3-resistor-fit (target)
  "Find the best combination of a resistor in series with two
  resistors in parallel to get the combined target resistance
  given."
  (perform-search '(+ r1 (/ (* r2 r3) (+ r2 r3))) 
		  '((r1 *standard-resistor-values*)
		    (r2 *standard-resistor-values*)
		    (r3 *standard-resistor-values*))
		  target))

(defun find-best-12parallel-3-resistor-fit (target)
  "Find the best combination of a resistor in parallel with two
  resistors in series to get the combined target resistance
  given."
  (perform-search '(/ (* r1 (+ r2 r3)) (+ r1 (+ r2 r3)))
		  '((r1 *standard-resistor-values*)
		    (r2 *standard-resistor-values*)
		    (r3 *standard-resistor-values*))
		  target))

(defun find-best-3parallel-3-resistor-fit (target)
  "Find the best combination of a three resistors in parallel to
  get the combined target resistance given."
  (perform-search '(/ 1d0 (+ (/ 1d0 r1) (/ 1d0 r2) (/ 1d0 r3)))
		  '((r1 *standard-resistor-values*)
		    (r2 *standard-resistor-values*)
		    (r3 *standard-resistor-values*))
		  target))

(defun find-best-3series-3-resistor-fit (target)
  "Find the best combination of a three resistors in series to
  get the combined target resistance given."
  (perform-search '(+ r1 r2 r3)
		  '((r1 *standard-resistor-values*)
		    (r2 *standard-resistor-values*)
		    (r3 *standard-resistor-values*))
		  target))

(defun find-best-3-resistor-fit (target)
  "Find the best combination of three resistors to get the
  combined target resistance given. Return the fit vector and a
  symbol indicating what type of arrangement was used."
  (find-best-fit (target)
    (find-best-1series-2parallel-3-resistor-fit :1series-2parallel-3-resistor)
    (find-best-12parallel-3-resistor-fit	:12parallel-3-resistor)
    (find-best-3parallel-3-resistor-fit		:3parallel-3-resistor)
    (find-best-3series-3-resistor-fit		:3series-3-resistor)))

;; Resistor fit interactive subroutines:

(defun resistor-fit-subroutine ()
  (let (number-of-resistors target )
    (tagbody
       (format *query-io* "How many resistors will be used? Only 2 or 3 resistors are~%supported, or 'both'. Default: try both.~%")
     :query-for-number-of-resistors
       (setf number-of-resistors (let ((line (prompt-for-line)))
				   (if (string= line "") 'both (read-from-string line nil nil))))
       (unless (or (eql number-of-resistors 2) (eql number-of-resistors 3) (eql number-of-resistors 'both))
	 (format *query-io* "Error: you must either enter 2 or 3, or press Enter to try both.~%")
	 (go :query-for-number-of-resistors))
       (format *query-io* "Enter the target value for the expression. Variable values
will be chosen to make the expression as close as possible
to the target value that you give.~%")
     :query-for-target
       (handler-case (setf target (coerce (eval (read-infix-expression (prompt-for-line))) 'double-float))
	 (error (e)
	   (format *query-io* "Error: ~A" e)
	   (go :query-for-target)))
       (if (eql number-of-resistors 'both)
	   (progn
	     (format *query-io* "Trying two resistors...~%")
	     (calculate-and-show-resistor-fit-subroutine 2 target)
	     (format *query-io* "Trying three resistors...~%")
	     (calculate-and-show-resistor-fit-subroutine 3 target))
	   (calculate-and-show-resistor-fit-subroutine number-of-resistors target)))))

(defun calculate-and-show-resistor-fit-subroutine (number-of-resistors target)
  "Calculate a resistor fit given the number of resistors and the
   target, then print out the fit."
  (let (answer fit-strategy)
    (multiple-value-bind (answers fit-strategy-temp)
	(if (= number-of-resistors 3)
	    (find-best-3-resistor-fit target)
	    (find-best-2-resistor-fit target))
      (setf answer (car answers))
      (setf fit-strategy fit-strategy-temp))
    ;; Display the answer
    (format *query-io* "Answer: ~a~%"
	    (apply #'format nil (get-resistor-fit-strategy-format-string fit-strategy)
		   (rotate1 (map 'list #'print-float-for-engineers answer))))))

(defun rotate1 (list)
  "Take the first element of LIST and shove it to the end of
  LIST. Non-destructive."
  (append (cdr list) (list (car list))))

(defun get-resistor-fit-strategy-format-string (fit-strategy)
  "Given a resistor-fit strategy, return a format string which
   will give proper output."
  ;; We get format args in the order (r1 r2 [r3] answer).
  (ecase fit-strategy
    (:series-2-resistor "~A + ~A = ~A")
    (:parallel-2-resistor "~A || ~A = ~A")
    (:1series-2parallel-3-resistor "~A + (~A || ~A) = ~A")
    (:12parallel-3-resistor "~A || (~A + ~A) = ~A")
    (:3parallel-3-resistor "~A || ~A || ~A = ~A")
    (:3series-3-resistor "~A + ~A + ~A = ~A")))

;; A real toplevel
;;;;;;;;;;;;;;;;;;

(defparameter *version* "1.0"
  "The version number of Parameter Scout, as a string.")

(defun quit (&optional (code 0))
  "Function to exit the Lisp implementation. Thanks to Kevin M. Rosenberg for the code."
  #+allegro (excl:exit code :quiet t)
  #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
  #+(or cmu scl) (ext:quit code)
  #+cormanlisp (win32:exitprocess code)
  #+gcl (lisp:bye code)
  #+lispworks (lw:quit :status code)
  #+lucid (lcl:quit code)
  #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
  #+mcl (ccl:quit code)
  #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
  (error 'not-implemented :proc (list 'quit code)))

(defun parameterscout-main ()
  "The main entry function of Parameter Scout"
  (parameterscout-interactive-main)
  #+cormanlisp (quit))

(defun parameterscout-interactive-main ()
  (tagbody
   :beginning
     (format *query-io* "Parameter Scout ~A: a program to pick out component values.~%~%" *version*)
   :menu
     (format *query-io* "Do you want to find the best combination of two or three
resistors to get a composite resistance, or would you prefer a
more general parameter fitting for amplifiers and such?

1. General-purpose parameter fitting

2. Combining resistors to do your bidding~%~%")
   :prompt-for-choice
     (format *query-io* "Enter the number of your choice, or q to quit. [default: 1]~%")
     (case (let ((line (prompt-for-line)))
	     (if (= (length line) 0)
		 1
		 (if (eql (elt line 0) #\q) (return-from parameterscout-interactive-main)
		     (parse-integer-safe line))))
       (1 (simple-toplevel))
       (2 (resistor-fit-subroutine))
       (t (format *query-io* "Error: that is not a valid choice. Please enter 1 or 2.~%")
	  (go :prompt-for-choice)))
     (pause)
     (format *query-io* "~%----------------------------------------------------------------~%~%")
     (go :menu)))